Programming Languages Suite/ProgramD2.iso/Visual Database/Visual BASIC 5.0 (Ent. Edition)/Vb5ent Extractor.EXE/VB/SAMPLES/ENTRPRIS/APE/AEPOOL/MODPOOL.BAS

BASIC Source File | 1996-12-06 | 25.5 KB | 561 lines

Attribute VB_Name = "modPoolMgr"
Option Explicit
'Declarations
Declare Function GetTickCount Lib "kernel32" () As Long



'Constants
Public Const gbSHOW_FORM_DEFAULT As Boolean = False
Public Const gbLOG_DEFAULT As Boolean = False
Public Const glWORKER_QUANTITY_DEFAULT As Long = 1
Public Const glLIST_BOX_MAX As Long = 500
Public Const giMAX_ALLOWED_RETRIES = 500
Public Const giRETRY_WAIT_MIN  As Integer = 500       'Retry Wait is measure in DoEvent cycles
Public Const giRETRY_WAIT_MAX  As Integer = 2500
Public Const gsPROTOCOL_DEFAULT As String = "ncacn_ip_tcp"
Public Const glAUTHENTICATION_DEFAULT As Long = 1
Public Const giWORKER_QUANTITY_DEFAULT As Integer = 1
Public Const gbWORKER_EARLYBIND_DEFAULT As Integer = True
Public Const giERROR_THRESHOLD As Integer = 32700
Public Const glMAX_LONG As Long = 2147483647

'User Defined Errors which also serve as string
'resource indexes
Public Const giNO_WORKERS_CREATED As Integer = 32764
Public Const giINVALID_PARAMETER As Integer = 32765
Public Const giCONNECTION_SETTING_FAILED As Integer = 32750     'An error was returned by RacReg32

'String resourse keys for logging messages
Public Const giPOOL_NAME As Integer = 2
Public Const giGET_WORKER As Integer = 3
Public Const giRELEASE_WORKER As Integer = 4
Public Const giCALL_REJECTED_RETRY As Integer = 11
Public Const giUSING_NO_AUTHENTICATION As Integer = 12
Public Const giONLY_N_WORKERS_CREATED As Integer = 13
Public Const giCOULD_NOT_CREATE_WORKER_ON_MACHINE As Integer = 14
Public Const giALL_WORKERS_CREATED As Integer = 15
Public Const giCOULD_NOT_CREATE_LOCAL_WORKER As Integer = 16
Public Const giERROR_PREFIX As Integer = 17

Public Const giFONT_CHARSET_INDEX As Integer = 30
Public Const giFONT_NAME_INDEX As Integer = 31
Public Const giFONT_SIZE_INDEX  As Integer = 32

'String resource keys for Form captions
Public Const giLBL_SATISFIED As Integer = 50
Public Const giLBL_REJECTED As Integer = 51
Public Const giLBL_NUM_WORKERS As Integer = 52
Public Const giPOOLMGR_CAPTION As Integer = 53

Public Const giRACREG_ERROR_CODE_OFFSET = 200               'Add offset to racreg32 error codes
                                                            'to make corresponding resource string key

'Public variables
Public gcWorkers As Collection              'This is basically the pool of available workers
Public gcWorkerMachines As Collection        'Collection of clsWorkerMachines objects used
                                             'keep track of how many worker objects are on
                                             'each remote worker machine.
Public glInstances As Long                  'A count of the number of instances made of PoolMgr
Public gbShow As Boolean                    'If true show PoolMgr form
Public gbLog As Boolean                     'If True log PoolMgr Events
Public goLogger As AELogger.Logger
Public gbLogWorkers As Boolean      'Flag to track status of
                                    'Worker property Log
Public gbUnloading As Boolean       'Flag used by Class_terminate
Public giWorkerCount As Integer              'Number of Worker instanciated, This can be different
                                             'than gcWorkers.Count if a Worker in the collection
                                             'is marked for removal it will not be included in giWorkerCount
Public glLastKeyUsed As Long                 'Last key used to add a worker to gcWorkers
                                             'It is necessary to use this because a the
                                             'giWorkerCount can be decreased but the Worker
                                             'not actually removed until it calls back after
                                             'completing a Service request.  During this time
                                             'WorkerQuantity can be called again to increase
                                             'the Worker count.  Therefore, giWorkerCount is
                                             'not reliable for generating unique keys
Public gbPersistentServices As Boolean      'Flag keeps track of Worker
                                            'property PersistentServices
                                            'If true Workers keep reference to
                                            'all Service objects used else they
                                            'drop references after each use.
Public gbEarlyBindServices As Boolean       'Flag to track status of
                                            'Worker property EarlyBound
Public gbStopTest As Boolean        'Stop Test flag, checked by many procedures
                                    'that will discontinue their processes if true
Public gsProtocol As String                 'Protocol sequence to use when connecting to Workers
Public glAuthentication As Long             'Authentication level to use when connecting to Workers
Public gbUseDCOM As Boolean                 'If true use DCOM to create workers instead of Remote Automation
Public glRequestsSatisfied As Long
Public glRequestsRejected As Long

Public Sub CountInitialize()
    '-------------------------------------------------------------------------
    'Purpose:   Keep track of number instances of PoolMgr and Pool
    '           To be called by a public creatable class in its initialize
    '           event. To keep track of how many public creatable objects
    '           are initialized.  Initialize the PoolMgr application if
    '           this is the first time it is called.
    'Effects:
    '           If this is the first instanciation
    '           Put the PoolMgr in a "Ready" state.  Load  Workers
    '           Set default properties, Show form and load logger if necessary.
    '   [glInstances]
    '           increments by one
    '-------------------------------------------------------------------------
    Dim i As Integer
    Dim oWork As clsWorker                   'Object storing Workers and related informantion
    Dim oWorkerMachine As clsWorkerMachines  'Object that stores how many
                                             'Workers are on what machines
    Dim sReturn As String           'Return of SetWorkersOnMachine function

    On Error GoTo CountInitializeError

    glInstances = glInstances + 1
    If glInstances = 1 Then
        App.OleServerBusyRaiseError = True
        App.OleServerBusyTimeout = 10000
        'Set default property values
        gbShow = gbSHOW_FORM_DEFAULT
        gbLog = gbLOG_DEFAULT
        gsProtocol = gsPROTOCOL_DEFAULT
        glAuthentication = glAUTHENTICATION_DEFAULT
        gbEarlyBindServices = gbWORKER_EARLYBIND_DEFAULT
        'Create Logger class object early so
        'potential errors could be logged
        If gbLog Then Set goLogger = New AELogger.Logger
        'Create collection objects
        Set gcWorkers = New Collection
        Set gcWorkerMachines = New Collection
        'Add an item to represent number of workers on the local machine
        Set oWorkerMachine = New clsWorkerMachines
        gcWorkerMachines.Add oWorkerMachine
        'Load the default amount of workers and add
        'them to the gcWorkers Collection
        sReturn = SetWorkersOnMachine(False, "", giWORKER_QUANTITY_DEFAULT)

        'Only show the form if gbShow is true
        If gbShow Then
            With frmPoolMgr
                .Show
                .lblStatus.Caption = ""
                .lblWorkers.Caption = CStr(giWorkerCount)
                .lblSatisfied.Caption = 0
                .lblRejected.Caption = 0
            End With
        End If
        gbUnloading = False
    End If
    Exit Sub
CountInitializeError:
    Select Case Err.Number
        Case ERR_CANT_FIND_KEY_IN_REGISTRY
            'AEInstancer.Instancer is a work around for error
            '-2147221166 which occurrs every time a client
            'object creates an instance of a remote server,
            'destroys it, registers it local, and tries to
            'create a local instance.  The client can not
            'create an object registered locally after it created
            'an instance while it was registered remotely
            'until it shuts down and restarts.  Therefore,
            'it works to call another process to create the
            'local instance and pass it back.
            Dim oInstancer As AEInstancer.Instancer
            Set oInstancer = New AEInstancer.Instancer
            Set goLogger = oInstancer.Object("AELogger.Logger")
            Set oInstancer = Nothing
            Resume Next
        Case Else
            LogError Err
            Resume Next
    End Select
End Sub

Public Sub CountTerminate()
    '-------------------------------------------------------------------------
    'Purpose:   Keep track of number instances of PoolMgr and Pool
    '           To be called by a public creatable class in its terminate
    '           event. To keep track of how many public creatable objects
    '           are initialized.  Terminate the PoolMgr application if
    '           this is the last time called.
    'Effects:
    '           Unload all objects, and unload form so that this application
    '           will close
    '   [glInstances]
    '           decrements by one
    '-------------------------------------------------------------------------
    Dim oWorker As clsWorker
    On Error GoTo Class_TerminateError
    glInstances = glInstances - 1
    'If already started unloading don't check
    'instance count again
    If Not gbUnloading Then
        If glInstances = 0 Then
            gbUnloading = True
            For Each oWorker In gcWorkers
                Set oWorker.Worker = Nothing
                Set oWorker = Nothing
            Next
            Set goLogger = Nothing
            Set gcWorkers = Nothing
            Set gcWorkerMachines = Nothing
            giWorkerCount = 0
            Unload frmPoolMgr
        End If
    End If
    Exit Sub
Class_TerminateError:
    LogError Err
    Resume Next
End Sub

Public Sub LogEvent(intMessage As Integer)
    'Receives Message key which is used to look
    'up a resource string.  The logrecord is sent to the
    'Logger object if gbLog is true
    On Error GoTo LogEventError
    If gbLog Then
        goLogger.Record LoadResString(giPOOL_NAME), 0, LoadResString(intMessage), GetTickCount()
    End If
    #If ccShowList Then
        'If the form is visible display log on form
        If gbShow Then
            DisplayString "0" & gsSEPERATOR & LoadResString(intMessage)
        End If
    #End If
    Exit Sub
LogEventError:
    LogError Err
    Exit Sub
End Sub

Public Sub LogError(ByVal oErr As ErrObject)
    'Display error on form with no user input required
    'Log error if logging is on
    Dim s As String
    s = LoadResString(giERROR_PREFIX) & Str$(oErr.Number) & gsSEPERATOR & oErr.Source & gsSEPERATOR & oErr.Description
    #If ccShowList Then
        If Not gbShow Then
            frmPoolMgr.Show
            gbShow = True
        End If
        DisplayString s
    #Else
        DisplayStatus s
    #End If
    If gbLog And glInstances <> 0 Then
        goLogger.Record LoadResString(giPOOL_NAME), 0, LoadResString(giERROR_PREFIX) & Str$(oErr.Number) & gsSEPERATOR & oErr.Source & gsSEPERATOR & oErr.Description, GetTickCount()
    End If
End Sub

Sub DisplayStatus(sText As String)
    If gbShow Then frmPoolMgr.lblStatus = sText
End Sub

Sub DisplayString(sText As String)
    #If ccShowList Then
        'Controls the length of the list box
        'and sets ListIndex
        Dim lstLog As ListBox
        If gbShow Then
            Set lstLog = frmPoolMgr.lstLog
            If lstLog.ListCount = glLIST_BOX_MAX Then lstLog.Clear
            lstLog.AddItem sText, 0
        End If
    #End If
End Sub

Sub Main()

End Sub

Public Function SetWorkersOnMachine(bRemote As Boolean, sMachineName As String, lQuantityOnMachine As Long) As String
    '-------------------------------------------------------------------------
    'Purpose:   Sets the quantity of instanciated Workers on a particular machine
    'IN:
    '   [bRemote]
    '           If true adjust number of workers on a remote machine; else,
    '           adjust the number on the local machine.
    '   [sMachineName]
    '           Name of machine to adjust the level of instanciated Workers
    '   [lQuantityOnMachine]
    '           Number of Instantiated Workers that should be on specified
    '           machine.
    'Return:    Discription of Errors that should be displayed to user
    'Effects:
    '   [gcWorkers]
    '           The number of Workers in this collection will be adjusted
    '   [gcWorkerMachines]
    '           An item may be added or removed or edited
    '-------------------------------------------------------------------------
    Dim oRacReg As RacReg.RegClass          'Object to set automation connection settings
    Dim oWorkerMachine As clsWorkerMachines 'Object that stores how many workers are on
                                            'a machine, retrieved from global collection
    Dim oWorkerProvider As AEWorkerProvider.WorkerProvider  'Server that can be instanciated on remote
                                                            'machines to provide Worker objects
    Dim lWorkerToRemove As Long             'ID of Worker found to remove
    Dim oWork As clsWorker                  'clsWorker object that hold reference to a Worker
                                            'and information related to it
    Dim lAdd As Long                        'New ID for New Worker
    Dim sErrors As String                   'Discription of Errors that will be returned
    Dim bAddingWorker As Boolean            'If true, adding and configuring worker
                                            'used by error handling

    Dim iRetry As Integer                   'Error retry counter
    Dim iResult As Integer                  'RacReg error code

    On Error GoTo SetWorkersOnMachineError

    'Validate lQuantityOnMachine
    If lQuantityOnMachine < 0 Then lQuantityOnMachine = 0

    'Set registry for local or remote machine name
    Set oRacReg = New RacReg.RegClass
    If bRemote Then
        If gbUseDCOM Then
            iResult = oRacReg.SetDCOMServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName)
        Else
            iResult = oRacReg.SetAutoServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName, gsProtocol, glAuthentication)
        End If
    Else
        'Make sure the Machine name string is zero length
        sMachineName = ""
        'Make sure AEWorker.Worker is registered for local instanciation
        'Because Clients may have been run on this machine and may have
        'left the connection settings remote if they did not unload properly
        iResult = oRacReg.SetAutoServerSettings(False, "AEWorker.Worker")

    End If
    If iResult <> 0 Then GoTo SetWorkersOnMachine_RacRegError

    'Get the clsWorkerMachines object to store information in
    If Not bRemote Then
        'it is definitely the first item in the collection
        Set oWorkerMachine = gcWorkerMachines.Item(1)
    Else
        'if it is in the collection it is stored by a key
        'equaling the machine name
        'If error equals ERR_INVALID_PROCEDURE_CALL there
        'are no Workers on specified machine and no clsWorkerMachines
        'class object to represent them
        On Error Resume Next
        Set oWorkerMachine = gcWorkerMachines.Item(sMachineName)
        If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
            On Error GoTo SetWorkersOnMachineError
            'Don't create a new clsWorkerMachine object of
            'lQuantityOnMachine is zero
            If lQuantityOnMachine <= 0 Then Exit Function
            Set oWorkerMachine = New clsWorkerMachines
            'If an error occurs creating WorkerProvider the current machine name
            'can not be used.  Treat error as if a Worker can not be created on
            'paticular machine.
            bAddingWorker = True
            Set oWorkerMachine.WorkerProvider = New AEWorkerProvider.WorkerProvider
            bAddingWorker = False

            gcWorkerMachines.Add oWorkerMachine, sMachineName
            With oWorkerMachine
                .Remote = True
                .MachineName = sMachineName
            End With
        End If
        On Error GoTo SetWorkersOnMachineError
        Set oWorkerProvider = oWorkerMachine.WorkerProvider
    End If

    'Now see if more workers need destroyed on this machine
    With oWorkerMachine
        If .WorkerKeys.Count > lQuantityOnMachine Then
            Do Until .WorkerKeys.Count <= lQuantityOnMachine
                'Find a worker on this machine
                lWorkerToRemove = .WorkerKeys.Item(1)
                .WorkerKeys.Remove 1
                'Remove the found worker
                'Do not destroy the Worker if it is busy
                'instead just flip its RemoveMe flag
                giWorkerCount = giWorkerCount - 1
                If gcWorkers.Item(CStr(lWorkerToRemove)).Busy Then
                    gcWorkers.Item(CStr(lWorkerToRemove)).RemoveMe = True
                Else
                    iRetry = 0
                    gcWorkers.Item(CStr(lWorkerToRemove)).Worker.ShutDown
                    Set gcWorkers.Item(CStr(lWorkerToRemove)).Worker = Nothing
                    gcWorkers.Remove CStr(lWorkerToRemove)
                End If
            Loop
        Else
            'Else lQuantityOnMachine must be greater than .WorkerKeys.count
            'So add to the collection
            bAddingWorker = True
            Do Until .WorkerKeys.Count = lQuantityOnMachine
                'Choose a unique key
                lAdd = glLastKeyUsed + 1
                glLastKeyUsed = lAdd
                Set oWork = New clsWorker
                oWork.Busy = False
                oWork.ID = lAdd
                'Get a new Worker object
                If bRemote Then
                    Set oWork.Worker = oWorkerProvider.GetWorker
                Else
                    Set oWork.Worker = New AEWorker.Worker
                End If
                'Set the WorkerID property of AEWorker.Worker
                'Set the new worker property to the properties
                'that have been set for the any other workers
                iRetry = 0
                oWork.Worker.SetProperties gbLogWorkers, gbEarlyBindServices, _
                        gbPersistentServices, lAdd
                'Add the clsWorker class object which holds a
                'reference to the Worker class object to gcWorkers collection
                'Use the WorkerID as the key
                gcWorkers.Add oWork, CStr(lAdd)
                giWorkerCount = giWorkerCount + 1
                .WorkerKeys.Add lAdd
                iRetry = 0
            Loop
            bAddingWorker = False
        End If
    End With
SetWorkersOnMachineEnd:
    'Update the WorkerCount label in the U/I
    'Set connection settings back to local
    iResult = oRacReg.SetAutoServerSettings(False, "AEWorkerProvider.WorkerProvider")
    If iResult <> 0 Then GoTo SetWorkersOnMachine_RacRegError

    If gbShow Then
        With frmPoolMgr.lblWorkers
            .Caption = gcWorkers.Count
            .Refresh
        End With
    End If

    'If the WorkerKeys.count = 0 and bRemote is true
    'then the clsWorkerMachines class
    'object in gcWorkerMachines should be removed
    'Don't remove the clsWorkerMachines object representing the
    'local machine.  Index one is reserved for the local machine.
    If oWorkerMachine.WorkerKeys.Count = 0 And bRemote Then
        On Error Resume Next
        gcWorkerMachines.Remove sMachineName
    End If
    SetWorkersOnMachine = sErrors
    Exit Function
SetWorkersOnMachine_RacRegError:
    Err.Raise giCONNECTION_SETTING_FAILED
SetWorkersOnMachineError:
    Select Case Err.Number
        Case RPC_E_CALL_REJECTED
            'Collision error, the OLE server is busy
            Dim il As Integer
            Dim ir As Integer
            'First check for stop test
            If iRetry < giMAX_ALLOWED_RETRIES Then
                iRetry = iRetry + 1
                ir = Int((giRETRY_WAIT_MAX - giRETRY_WAIT_MIN + 1) * Rnd + giRETRY_WAIT_MIN)
                For il = 0 To ir
                    DoEvents
                Next il
                LogEvent giCALL_REJECTED_RETRY
                Resume
            Else
                'We reached our max retries
                GoTo SetWorkersOnMachineUnexpectedError
            End If
        Case ERR_CANT_FIND_KEY_IN_REGISTRY
            'AEInstancer.Instancer is a work around for error
            '-2147221166 which occurrs every time a client
            'object creates an instance of a remote server,
            'destroys it, registers it local, and tries to
            'create a local instance.  The client can not
            'create an object registered locally after it created
            'an instance while it was registered remotely
            'until it shuts down and restarts.  Therefore,
            'it works to call another process to create the
            'local instance and pass it back.
            Dim oInstancer As AEInstancer.Instancer
            Set oInstancer = New AEInstancer.Instancer
            Set oWorkerProvider = oInstancer.Object("AEWorkerProvider.WorkerProvider")
            Set oInstancer = Nothing
            Resume Next
        Case RPC_S_UNKNOWN_AUTHN_TYPE
            'Tried to connect to a server that does not support
            'specified authentication level.  Display message and
            'switch to no authentication and try again
            Dim s As String
            s = ReplaceString(LoadResString(giUSING_NO_AUTHENTICATION), gsNAME_TOKEN, sMachineName)
            LogText s
            sErrors = s & vbCrLf
            iResult = oRacReg.SetAutoServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName, gsProtocol, glAUTHENTICATION_DEFAULT)
            Resume
        Case ERR_OVER_FLOW
            glLastKeyUsed = 0
            Resume
        Case ERR_DUPLICATE_KEY
            'Assusmes on line "gcWorkers.Add oWork, cstr(lAdd)"
            If lAdd = glMAX_LONG Then lAdd = 0 Else lAdd = lAdd + 1
            glLastKeyUsed = lAdd
            oWork.ID = lAdd
            Resume
        Case giCONNECTION_SETTING_FAILED
            sErrors = ReplaceString(LoadResString(giCONNECTION_SETTING_FAILED), gsNAME_TOKEN, LoadResString(giRACREG_ERROR_CODE_OFFSET + iResult))
            Err.Raise giNO_WORKERS_CREATED, , sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
        Case Else
SetWorkersOnMachineUnexpectedError:
            'There are three cases to respond to if there is an unexpected error
            '1- If the error occured while NOT adding a worker it most likely
            '   occured while removing one.  Resume Next to insure that the worker
            '   is removed from the workers collection.
            '2- If we were adding a worker and the worker class was registered local
            '   log the error, and add it to the sError string, but raise the
            '   giNO_WORKERS_CREATED error, because the system has a critical problem
            '   if a local worker can not be created.
            '3- If we were adding a worker and the worker class was registered remote
            '   log the error, and add it to the sError string.  Exit procedure so
            '   that calling procedure can try creating workers on another machine
            Dim sSource As String
            sSource = Err.Source
            sErrors = sErrors & sMachineName & gsSEPERATOR & sSource & gsSEPERATOR & Err.Description & vbCrLf
            LogError Err
            If Not bAddingWorker Then
                Resume Next
            Else
                If bRemote Then
                    sErrors = sErrors & vbCrLf & ReplaceString(LoadResString(giCOULD_NOT_CREATE_WORKER_ON_MACHINE), gsNAME_TOKEN, sMachineName)
                    Resume SetWorkersOnMachineEnd
                Else
                    iResult = oRacReg.SetAutoServerSettings(False, "AEWorkerProvider.WorkerProvider")
                    sErrors = sErrors & vbCrLf & LoadResString(giCOULD_NOT_CREATE_LOCAL_WORKER)
                    Err.Raise giNO_WORKERS_CREATED, sSource, sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
                End If
            End If
    End Select
End Function

Public Sub LogText(sMsg As String)
    '-------------------------------------------------------------------------
    'Purpose:   Passes that passed string as a log record
    '           to the logger
    'In:        [sMsg]
    '               String to be logged
    '           [lServiceID]
    '               Service Request ID to be logged
    'Assumption:
    '           If gbLog is true then goLogger is a valid reference to
    '           AELogger.Logger class object
    '-------------------------------------------------------------------------
    On Error GoTo LogTextError
    If gbLog And Not gbStopTest Then
        goLogger.Record LoadResString(giPOOL_NAME), 0, sMsg, GetTickCount()
    End If
    'If the form is visible display log on form
    #If ccShowList Then
        DisplayString CStr(lServiceID) & gsSEPERATOR & sMsg
    #End If
    Exit Sub
LogTextError:
    LogError Err
    Exit Sub
End Sub